#lang sicp
(define (make-table)
  (define (make-table data-set) (cons 'table data-set))
  (define (empty-table? t) (empty-data-set? (cdr t)))
  (define (set-table-data-set! table data-set)
    (set-cdr! table data-set))
  (define (data-set-table t) (cdr t))

  (define (make-data-set) '())
  (define (empty-data-set? d) (null? d))
  (define (insert-data-set set data)
    (cons data set))
  (define (find-data-set data-set key)
    (cond ((empty-data-set? data-set) #f)
          ((equal? key (key-data (car data-set))) (car data-set))
          (else
           (find-data-set (cdr data-set) key))))

         
  (define (make-data key record sub-table)
    (list key record sub-table))
  (define (key-data data) (car data))
  (define (record-data data) (cadr data))
  (define (sub-table-data data) (caddr data))
  (define (set-record-data! new-value data)
    (set-car! (cdr data) new-value))

  (define (last-keys? keys) (null? (cdr keys)))
  (define (create-data keys content)
    (define (iter keys)
      (if (last-keys? keys)
          (make-data (car keys) content (make-table (make-data-set)))
          (let ((data (iter (cdr keys)))
                (data-set (make-data-set)))
            (make-data (car keys) nil (make-table (insert-data-set data-set data))))))
    (iter keys))
  
  (define (put keys content table)
    (define (iter keys t)
      (if (empty-table? t)
          (let ((data-set (make-data-set))
                (data (create-data keys content)))
            (set-table-data-set! t (insert-data-set data-set data)))
          (let ((key (car keys))
                (data-set (data-set-table t)))
            (let ((data (find-data-set data-set key)))
              (if data
                  (if (last-keys? keys)
                      (set-record-data! content data)
                      (iter (cdr keys) (sub-table-data data)))
                  (let ((data (create-data keys content)))
                    (set-table-data-set! t (insert-data-set data-set data))))))))
    (iter keys table))

  (define (get keys table)
    (let ((key (car keys))
          (data-set (data-set-table table)))
      (if (empty-data-set? data-set)
          #f
          (let ((data (find-data-set data-set key)))
            (if data
                (if (last-keys? keys)
                    data
                    (get (cdr keys) (sub-table-data data)))
                #f)))))

  
  (let ((table (make-table nil)))
    (define (dispatch m)
      (cond ((eq? m 'put)
             (lambda (op types proc)
               (put (list op types) proc table)))
            ((eq? m 'get)
             (lambda (op types)
               (let ((data (get (list op types) table)))
                 (if data
                     (record-data data)
                     #F))))
            (else
             (error "unknowed operation -- MAKE-TABLE" m))))
    dispatch))

;; main
(define arithmetic-table (make-table))
(define get (arithmetic-table 'get))
(define put (arithmetic-table 'put))


(define coercion-table (make-table))
(define get-coercion (coercion-table 'get))
(define put-coercion (coercion-table 'put))


(define (get-type x)
  (if (number? x)
      'number
      (car x)))
(define (get-content x)
  (if (number? x)
      x
      (cdr x)))
(define (attach-type type x) (cons type x))
(define (square x) (mul x x))


(define (apply-generic op . args)
  (define (try-raise-type)
    (let ((highest-type (find-highest-type (map get-type args))))
      (let ((new-args (raise-all-to-type highest-type args)))
        (let ((types (map get-type new-args))
              (contents (map get-content new-args)))
          (let ((proc (get op types)))
            (if proc
                (apply proc contents)
                (error "No method for these types -- APPLY-GENERIC" (list op types))))))))
  (define (run)
    (let ((types (map get-type args))
        (contents (map get-content args)))
    (let ((proc (get op types)))
      (if proc
          (apply proc contents)
          (if (all-equal? types)
              (error "No method for these types" types)
              (try-raise-type))))))
  (drop (run)))


(define (all-equal? se)
  (define (iter t se)
    (cond ((null? se) #T)
          ((equal? t (car se)) (iter t (cdr se)))
          (else #F)))
  (if (pair? se)
      (iter (car se) (cdr se))
      (error "Must be pair! -- ALL-EQUAL?" se)))

;; tower structure
(define (make-tower)
  (define data '(tower-bottom))
  (define tower-bottom 'tower-bottom)
  (define (join-supertype subtype supertype)
    (define (join se)
      (cond ((null? se) (error "the subtype given don't found! -- JOIN-SUPERTYPE" subtype))
            ((eq? (car se) subtype)
             (set-cdr! se (cons supertype (cdr se))))
            (else
             (join (cdr se)))))
    (join data))
  (define (get-type-level type)
    (define (iter se n)
      (cond ((null? se) (error "No this type in the tower" type))
            ((eq? (car se) type) n)
            (else (iter (cdr se) (+ 1 n)))))
    (iter data 0))
  (define (dispatch m)
    (cond ((eq? m 'get-type-level) get-type-level)
          ((eq? m 'join-supertype) join-supertype)
          ((eq? m 'tower-bottom) tower-bottom)
          (else
           (error "unknown method! -- MAKE-TOWER" m))))
  dispatch)
(define (raise o)
  (let ((type (get-type o))
        (content (get-content o)))
    (let ((proc (get 'raise type)))
      (if proc
          (proc o)
          (error "Don't raise -- RAISE" type)))))
(define (project o)
  (let ((p (get 'project (get-type o))))
    (if p
        (p o)
        #F)))
(define (drop o)
  (define (iter o)
    (let ((p (project o)))
      (if p
          (let ((res (raise-to-type (get-type o) p)))
            (if (equ? res o)
                (let ((next-drop-res (iter p)))
                  (if next-drop-res
                      next-drop-res
                      p))
                #F))
          #F)))
  (if (tower-number-type? o)
      (let ((res (iter o)))
        (if res
            res
            o))
      o))
(define (tower-number-type? o)
  (or (number? o) (pair? o)))
(define (find-highest-type types)
  (if (list-length-eq types 1)
      (car types)
      (accumulate (lambda (type other)
                    (let ((l1 (tower-type-level type))
                          (l2 (tower-type-level other)))
                      (if (> l1 l2)
                          type
                          other)))
                  (cdr types)
                  (car types))))


(define (raise-to-type type o)
  (if (eq? type (get-type o))
      o
      (raise-to-type type (raise o))))
(define (list-length-eq l n)
  (cond ((null? l)
         (if (= n 0) #T #F))
        ((<= 0) #F)
        (else
         (list-length-eq (cdr l) (- n 1)))))
(define (accumulate combine se init)
  (if (null? se)
      init
      (combine (car se)
               (accumulate combine (cdr se) init))))
(define (raise-all-to-type highest-type args)
  (map (lambda (cur)
         (if (eq? (get-type cur) highest-type)
             cur
             (raise-to-type highest-type cur)))
       args))

;; install raise
(define (install-tower-raise)
  (define (number-to-rational number)
    (make-rational number 1))
  (define (real-to-complex real)
    (make-from-real-imag (get-content real) 0))
  (define (rational-to-real rat)
    (make-real (/ (numer rat) (denom rat))))

  (put 'raise 'number number-to-rational)
  (put 'raise 'rational rational-to-real)
  (put 'raise 'real real-to-complex)
  'done-install-tower-raise
  )
(install-tower-raise)

;; install projection
(define (install-projection)
  (define (project-complex c) (real-part c))
  (define (project-real real)
    (round (get-content real)))
  (define (project-rational r)
    (numer r))

  (put 'project 'complex project-complex)
  (put 'project 'real project-real)
  (put 'project 'rational project-rational)
  'done-install-projection)
(install-projection)


;; create tower
(define tower-type (make-tower))
(define tower-type-level (tower-type 'get-type-level))
(define (tower-join-supertype subtype supertype)
  ((tower-type 'join-supertype) subtype supertype))
(define tower-bottom (tower-type 'tower-bottom))

(tower-join-supertype tower-bottom 'number)
(tower-join-supertype 'number 'rational)
(tower-join-supertype 'rational 'complex)
(tower-join-supertype 'rational 'real)



;; generic arithmetic operation
(define (add a b)
  (apply-generic 'add a b))
(define (sub a b)
  (apply-generic 'sub a b))
(define (mul a b)
  (apply-generic 'mul a b))
(define (div a b)
  (apply-generic 'div a b))
(define (equ? a b)
  (apply-generic 'equ? a b))
(define (=zero? a) (apply-generic '=zero? a))
(define (exp b e) (apply-generic 'exp b e))
(define (cosine n) (apply-generic 'cosine n))
(define (sine n) (apply-generic 'sine n))
(define (squareroot n) (apply-generic 'squareroot n))
(define (arctan a b) (apply-generic 'arctan a b))

(define (make-from-real-imag r i)
  ((get 'make-from-real-imag 'complex) r i))
(define (make-from-mag-ang m a)
  ((get 'make-from-mag-ang 'complex) m a))
(define (make-rational numer denom)
  ((get 'make-rational 'rational) numer denom))
(define (make-real n)
  ((get 'make-real 'real) n))


(define (real-part x)
  (apply-generic 'real-part x))
(define (imag-part x)
  (apply-generic 'imag-part x))
(define (magnitude x)
  (apply-generic 'magnitude x))
(define (angle x)
  (apply-generic 'angle x))

(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)


(define (numer rat)
  (apply-generic 'numer rat))
(define (denom rat)
  (apply-generic 'denom rat))

;; install complex arithmetic package
(define (install-complex-arithmetic-package)
  (define (add-complex z1 z2)
    (make-from-real-imag (add (real-part z1) (real-part z2))
                         (add (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (sub (real-part z1) (real-part z2))
                         (sub (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (mul (magnitude z1) (magnitude z2))
                       (add (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (div (magnitude z1) (magnitude z2))
                       (sub (angle z1) (angle z2))))
  (define (equ-complex? z1 z2)
    (and (equ? (real-part z1) (real-part z2))
         (equ? (imag-part z1) (imag-part z2))))
  (define (=zero? z)
    (and (equ? (real-part z) 0) (equ? (imag-part z) 0)))
  
  
  (define (make-from-mag-ang m a)
    (attach-type 'polar ((get 'make-from-mag-ang '(polar)) m a)))
  (define (make-from-real-imag m a)
    (attach-type 'rectangular ((get 'make-from-real-imag '(rectangular)) m a)))


  ;; install sub package
  (define (install-complex-polar)
    (define (real-part z) (mul (magnitude z) (cosine (angle z))))
    (define (imag-part z) (mul (magnitude z) (sine (angle z))))
    (define (magnitude z) (car z))
    (define (angle z) (cdr z))
    (define (make-from-real-imag x y)
      (cons (squareroot (add (square x) (square y)))
            (arctan y x)))
    (define (make-from-mag-ang r a) (cons r a))

    ;; install
    (define type 'polar)
    (define set (lambda (op type proc)
                  (put op (list type) proc)))
    (set 'real-part type real-part)
    (set 'imag-part type imag-part)
    (set 'magnitude type magnitude)
    (set 'angle type angle)
    (set 'make-from-real-imag type make-from-real-imag)
    (set 'make-from-mag-ang type make-from-mag-ang)
    'done--install-complex-polar)

  (define (install-complex-rectangular)
    (define (real-part z) (car z))
    (define (imag-part z) (cdr z))
    (define (magnitude z)
      (squareroot (add (square (real-part z))
               (square (imag-part z)))))
    (define (angle z)
      (arctan (imag-part z) (real-part z)))
    (define (make-from-real-imag x y) (cons x y))
    (define (make-from-mag-ang r a)
      (cons (mul r (cosine a)) (mul r (sine a))))

    ;;install
    (define type 'rectangular)
    (define set (lambda (op type proc)
                  (put op (list type) proc)))
    (set 'real-part type real-part)
    (set 'imag-part type imag-part)
    (set 'magnitude type magnitude)
    (set 'angle type angle)
    (set 'make-from-real-imag type make-from-real-imag)
    (set 'make-from-mag-ang type make-from-mag-ang)
    'done--install-complex-rectangular)
  (install-complex-rectangular)
  (install-complex-polar)

  
  (define (tag content) (attach-type 'complex content))
  (put 'add '(complex complex)
       (lambda (x y) (tag (add-complex x y))))
  (put 'sub '(complex complex)
       (lambda (x y) (tag (sub-complex x y))))
  (put 'mul '(complex complex)
       (lambda (x y) (tag (mul-complex x y))))
  (put 'div '(complex complex)
       (lambda (x y) (tag (div-complex x y))))
  (put 'make-from-real-imag 'complex
       (lambda (r i)
         (tag (make-from-real-imag r i))))
  (put 'make-from-mag-ang 'complex
       (lambda (m a)
         (tag (make-from-mag-ang m a))))
  (put 'equ? '(complex complex) equ-complex?)
  (put '=zero? '(complex) =zero?)
  'done--install-complex-arithmetic-package
)

(install-complex-arithmetic-package)





;; install common number arithmetic
(define (install-number-arithmetic-package)
  (put 'add '(number number) +)
  (put 'sub '(number number) -)
  (put 'div '(number number) (lambda (x y) (floor (/ x y))))
  (put 'mul '(number number) *)
  (put 'equ? '(number number) =)
  (put '=zero? '(number) (lambda (x) (= x 0)))
  (put 'exp '(number number) expt)
  (put 'sine '(number) (lambda (x) (sine (make-real x))))
  (put 'cosine '(number) (lambda (x) (cosine (make-real x))))
  (put 'arctan '(number number) (lambda (x y) (arctan (make-real x) (make-real y))))
  (put 'squareroot '(number) (lambda (x) (squareroot (make-real x))))
  'done-install-number-arithmetic-package)

(install-number-arithmetic-package)



;; install real number arithmetic
(define (install-real-arithmetic-package)
  (define (tag x) (attach-type 'real x))
  (put 'add '(real real) (lambda (x y) (tag (+ x y))))
  (put 'sub '(real real) (lambda (x y) (tag (- x y))))
  (put 'div '(real real) (lambda (x y) (tag (/ x y))))
  (put 'mul '(real real) (lambda (x y) (tag (* x y))))
  (put 'sine '(real) (lambda (x) (tag (sin x))))
  (put 'cosine '(real) (lambda (x) (tag (cos x))))
  (put 'squareroot '(real) (lambda (x) (tag (sqrt x))))
  (put 'arctan '(real real) (lambda (x y) (tag (atan x y))))
  (put 'equ? '(real real) =)
  (put '=zero? '(real) (lambda (x) (= x 0)))
  (put 'exp '(real real) expt)
  (put 'make-real 'real (lambda (n) (tag (add n 0.0))))
  'done-install-real-number-arithmetic-package)
(install-real-arithmetic-package)

;; install rational arithmetic
(define (install-rational-arithmetic-package)
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
              (* (denom x) (numer y))))
  (define (sine-rat x)
    (sine (to-real x)))
  (define (cosine-rat x)
    (cosine (to-real x)))
  (define (equa-rat? x y)
    (= (* (numer x) (denom y))
       (* (numer y) (denom x))))
  (define (=zero? x)
    (= (numer x) 0))
  (define (to-real rat)
    (div (make-real (numer rat))
         (make-real (denom rat))))
  
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))
  (define (numer x) (car x))
  (define (denom x) (cdr x))

  ;; install
  (define (tag x) (attach-type 'rational x))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))
  (put 'sine '(rational)(lambda (x) (sine-rat x)))
  (put 'cosine '(rational) (lambda (x) (cosine-rat x)))
  (put 'squareroot '(rational) (lambda (x) (squareroot (to-real x))))
  (put 'arctan '(rational rational) (lambda (x y) (arctan (to-real x) (to-real y))))
  (put 'make-rational 'rational
       (lambda (numer denom)
         (tag (make-rat numer denom))))
  (put 'equ? '(rational rational) equa-rat?)
  (put '=zero? '(rational) =zero?)
  (put 'numer '(rational) numer)
  (put 'denom '(rational) denom)
  'done-install-rational-arithmetic-package)

(install-rational-arithmetic-package)




;; install coercion
(put-coercion 'number 'complex
              (lambda (n)
                (make-from-real-imag n 0)))
(put-coercion 'number 'rational
              (lambda (n)
                (make-rational n 1)))


;; test
(define a 2)
(define b 4)
(define c-a (make-from-real-imag 3 4))
(define c-b (make-from-mag-ang 5 (make-real 0.729)))
(define c-c (make-from-real-imag 3 0))
(define c-cc (make-from-real-imag (make-real 3.5) 0))
(define rat-a (make-rational 1 2))
(define rat-b (make-rational 3 4))
(define rat-c (make-rational 2 1))
(define r-a (make-real 3.2))
(define r-b (make-real 1.5))
(define r-c (make-real 4.0))

(define c-d (make-from-real-imag (make-rational 1 2)
                                 (make-rational 3 4)))
(define c-f (make-from-real-imag (make-rational 1 4)
                                 (make-rational 1 10)))
(define c-g (make-from-real-imag (make-real 3.3)
                                 (make-rational 1 2)))
